home *** CD-ROM | disk | FTP | other *** search
Path: uunet!rs From: rs@uunet.UU.NET (Rich Salz) Newsgroups: comp.sources.unix Subject: v10i087: Common Loops, Common Objects, Common Lisp, Part13/13 Message-ID: <758@uunet.UU.NET> Date: 3 Aug 87 21:20:32 GMT Organization: UUNET Communications Services, Arlington, VA Lines: 1802 Approved: rs@uunet.UU.NET Submitted-by: Roy D'Souza <dsouza%hplabsc@hplabs.HP.COM> Posting-number: Volume 10, Issue 87 Archive-name: comobj.lisp/Part13 #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 13 (of 13)." # Contents: co-parse.l PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'co-parse.l' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'co-parse.l'\" else echo shar: Extracting \"'co-parse.l'\" \(56836 characters\) sed "s/^X//" >'co-parse.l' <<'END_OF_FILE' X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; X; File: co-parse.l X; RCS: $Revision: 1.1 $ X; SCCS: %A% %G% %U% X; Description: Commonobjects parser for the Commonobjects-Commonloops X; interface. X; Author: Roy D'Souza, HPL/DCC X; Created: 20-Nov-86 X; Modified: 4-Mar-87 11:22:29 (James Kempf) X; Mode: Lisp X; Package: COMMON-OBJECTS-PARSER X; Status: Distribution X; X; (c) Copyright 1987, HP Labs, all rights reserved. X; X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; X; Copyright (c) 1987 Hewlett-Packard Corporation. All rights reserved. X; X; Use and copying of this software and preparation of derivative works based X; upon this software are permitted. Any distribution of this software or X; derivative works must comply with all applicable United States export X; control laws. X; X; This software is made available AS IS, and Hewlett-Packard Corporation makes X; no warranty about the software, its performance or its conformity to any X; specification. X; X; Suggestions, comments and requests for improvement may be mailed to X; aiws@hplabs.HP.COM X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Preliminaries X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(provide "co-parse") X X;;;Package COMMON-OBJECTS-PARSER contains the parser. For ease of X;;; typing, CO-PARSER can be used. X X;;;These symbols from the COMMON-OBJECTS package are needed at compile X;;; time. Create the package if not there. Note that I don't want X;;; to export them, because a user of the COMMON-OBJECTS package X;;; shouldn't know about them. I therefore use fully qualified X;;; symbols in the code. X X(in-package :common-objects :nicknames '(co) :use '(lisp pcl)) X(intern "ASSIGNEDP") X(intern "METHOD-ALIST") X(intern "SELF") X(intern "INIT-KEYWORDS") X(intern "LEGAL-PARENT-P") X(in-package 'common-objects-parser :nicknames '(co-parser) :use '(lisp pcl)) X X;;Export functions needed for parsing X X(export X '( X co-parse-define-type-call X co-parse-method-macro-call X co-parse-call-to-method X co-process-var-options X co-parse-options X co-deftype-error X co-legal-type-or-method-name X $UNDEFINED-TYPE-NAME X $TYPE-INFO-SLOT X $TYPE-NAME-SLOT X $VARIABLE-NAMES-SLOT X $INITABLE-VARIABLES-SLOT X $SETTABLE-VARIABLES-SLOT X $GETTABLE-VARIABLES-SLOT X $PARENT-TYPES-SLOT X $PARENTS-INFO-SLOT X $A-LIST-METHOD-TABLE-SLOT X $TREAT-AS-VARIABLES-SLOT X $INIT-KEYWORDS-SLOT X $NO-INIT-KEYWORD-CHECK-SLOT X $METHODS-TO-NOT-DEFINE-SLOT X $METHODS-TO-INHERIT-SLOT X $LET-PSEUDO-INFO-SLOT X $INFO-NUMBER-OF-SLOTS X X ) X) X X;;Need the PCL and pcl-patches module X(require "pcl") X(require "pcl-patches") X X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Constant Definition X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;Type names are set to this when types are undefined. X X(defconstant $UNDEFINED-TYPE-NAME '*now-an-undefined-type*) X X;;Offsets into the vector used to parse type definitions. X X(defconstant $TYPE-INFO-SLOT 0) X X(defconstant $TYPE-NAME-SLOT 1) X X(defconstant $VARIABLE-NAMES-SLOT 2) X X(defconstant $INITABLE-VARIABLES-SLOT 3) X X(defconstant $SETTABLE-VARIABLES-SLOT 4) X X(defconstant $GETTABLE-VARIABLES-SLOT 5) X X(defconstant $PARENT-TYPES-SLOT 6) X X(defconstant $PARENTS-INFO-SLOT 7) X X(defconstant $A-LIST-METHOD-TABLE-SLOT 8) X X(defconstant $TREAT-AS-VARIABLES-SLOT 9) X X(defconstant $INIT-KEYWORDS-SLOT 10) X X(defconstant $NO-INIT-KEYWORD-CHECK-SLOT 11) X X(defconstant $METHODS-TO-NOT-DEFINE-SLOT 12) X X(defconstant $METHODS-TO-INHERIT-SLOT 13) X X(defconstant $LET-PSEUDO-INFO-SLOT 14) X X(defconstant $EXPLICITLY-LISTED-METHODS-SLOT 15) X X;;List of all universal method names X X(defconstant X $DEFINE-TYPE-UNIVERSAL-METHODS X '(:describe X :print X :initialize X :initialize-variables X :init X :eql X :equal X :equalp X :typep X :copy X :copy-state X :copy-instance) X) X X;;Size of the vector used in type definition parsing. X X(defconstant $INFO-NUMBER-OF-SLOTS 16) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; General Macro Definitions X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(defmacro get-parents-info (type-info) X X; Allow for more convenient access of parent information. X X `(aref ,type-info $parents-info-slot)) X X(defmacro set-parents-info (type-info new-value) X `(setf (aref ,type-info $parents-info-slot) ,new-value)) X X(defmacro co-deftype-error (format &rest arguments) X X `(error (concatenate 'simple-string X "DEFINE-TYPE: In type '~s', " X ,format) X ,@arguments)) X X X(defmacro define-method-error (format &rest arguments) X X `(error X (format nil X (concatenate 'simple-string "DEFINE-METHOD: " ,format) X ,@arguments))) X X(defmacro return-keyword-from-variable (var) X `(intern ,var (find-package "KEYWORD")) X) X X;;type-partially-defined?-Find out if a CommonLoops class is X;; defined and return the class object if so. X X(defmacro type-partially-defined? (name) X X `(class-named ,name T)) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; General Function and Method Definitions X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X;;type-name-Return the name of the type X X(defun type-name (tinfo) X X (if (%instancep tinfo) X (class-name tinfo) X (svref tinfo $TYPE-NAME-SLOT) X ) X X) ;type-name X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Top Level Type Definition X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X X(defun co-parse-define-type-call X (define-type-call type-name doc-string options-list) X X; Parse the various pieces of the call to DEFINE-TYPE. Return multiple values X; of the form: (TYPE-NAME DOC-STRING OPTIONS-LIST) OPTIONS-LIST doesn't have to X; exist. If it doesn't, NIL is returned for it value (assuming NIL is X; given as their initial value passed into the routine). In either X; case it is disreguarded. Example call, DEFINE-TYPE-CALL = X; (DEFINE-TYPE NOSE (:INHERIT-FROM PARENT)). X X (setf define-type-call (cdr define-type-call)) X X; This should now be the list of arguments to the DEFINE-TYPE. X; Example define-type-call = (NOSE (:INHERIT-FROM PARENT)). X X (unless (proper-list define-type-call) X X ; THEN The call to DEFINE-TYPE is not a proper list. X X (error X (format nil X "DEFINE-TYPE: The call,~% (DEFINE-TYPE '~S'),~% is missing arguments or is not a proper list." X define-type-call))) X X; Get the name of the type X X (setf type-name (first define-type-call)) X (setf define-type-call (cdr define-type-call)) X X; see if there is a documentation string X X (when X (setq doc-string X (and (consp define-type-call) X (stringp (car (the cons define-type-call))) X (list (car (the cons define-type-call))) X ; list form for ,@ substitution X )) X (setf define-type-call (cdr define-type-call))) X X; Example, define-type-call = ((:INHERIT-FROM PARENT)). X; Now look for options. X X (when (consp define-type-call) X X ; THEN We have options. X X (setf options-list define-type-call)) X X; Return the parsed fields as a list for MULTIPLE-VALUE-SETQ X X (values type-name doc-string options-list) X X) ;co-parse-define-type-call X X;;proper-list-Return T if X is a proper list, i.e., no dotted tail X X(defun proper-list (x) X X; Return T on if x is a proper list (i.e., not (a b c . d)). NIL is X; not considered a proper list. X X (and (consp x) (not (cdr (last x))))) X X(defun co-process-var-options X (type-info options-list var-names var-assignments) X X; Returns multiple values. These values are: X; (VAR-NAMES VAR-ASSIGNMENTS OPTIONS-LIST) X; Go through OPTIONS-LIST and find all the :VAR options. Take X; these and process them producing the list of variable names, the X; variable assignment code and the list of options without the :VAR X; options. X X (let X ( X (variable nil) X (var-assignment nil) X (new-options-list nil) X (option-name nil) X (option-info nil) X ) X;;;; (Declare (ignore option-name)) X X (dolist (option options-list X (values var-names var-assignments new-options-list) X ) X X (multiple-value-setq (option-name option-info) X (option-ok? option type-info 'regular-option) X ) X X ; Will only return to here if we didn't get an error. X X ; Check if spec is an instance variable spec X X (if (not (member 'variable-option (cdr option-info) :test #'eq)) X X ;;THEN Add this non-:VAR option to the options list X X (setf new-options-list (nconc new-options-list (list option))) X X X X ; ELSE We have a instance variable specification. X ; Now return the name of the variable and initialization X ; code. X X X (progn X (multiple-value-setq (variable var-assignment) X (parse-option X type-info X var-names X option X option-info X ) X ) X X X (setf var-names (nconc var-names (list variable))) X X (when var-assignment X X ; THEN Add the assignment to the list of assignments. X X (setf var-assignments X (nconc var-assignments (list var-assignment)) X ) X ) ;when X X ) ;progn X X ) ;if X ); dolist X X ) ;let X X); end co-process-var-options X X(defun co-parse-options (type-info var-names options) X X; It is legal for OPTIONS to be NIL. X; Example: OPTIONS = ((:REDEFINED-METHODS m1 m2 m3) X; :ALL-INITABLE) X X (let ((options-so-far nil) X (option-name nil) X (option-info nil)) X X (dolist (option options) X X ; OPTION-INFO will be NIL if OPTION-NAME is not a legal X ; option, or a list of information that tells what X ; characteristics this option has. Note that currently, if an X ; error occurs in OPTION-OK? we will NOT return to this X ; function. The check for '(WHEN OPTION-INFO...' is for future X ; continuable errors. If 'ONCE' is on this list, it means the X ; option can only occur once. X X (multiple-value-setq (option-name option-info) X (option-ok? option type-info 'regular-option)) X (when option-info X X ; THEN The OPTION is a real one. X ; Now make sure it doesn't occur more then once. X X (if X (and (member option-name options-so-far :test #'eq) X X (member 'once (cdr option-info) :test #'eq)) X X ; THEN We have duplicate options. Give an error. X X (co-deftype-error X "duplicate option,~% '~s',~% specified." X (type-name type-info) X option) X X ; ELSE Everything is ok. X X (progn X (setf options-so-far (cons option-name options-so-far)) X (parse-option type-info var-names option option-info))))) X )) X X(defun parse-option (type-info var-names option option-info) X X; This routine calls the right function to parse OPTION. This X; function is the first element of OPTION-INFO. Example: OPTION = X; (:REDEFINED-METHODS M1 M2 M3) The option given is either a symbol X; or a list. When a list, the rest of the arguments will be passed to X; the function (may be NIL). If a symbol, NIL is passed as arguments. X; NOTE: Should make sure that the value returned by the option is X; the value of this routine, since some code may want to use X; the value returned (like the caller of the :VAR option). X X (apply (car option-info) X (list var-names (if (consp option) (cdr option) nil) type-info))) X X(defun option-ok? (option type-info type-of-option) X X; Return the information about this option or NIL. Return the name of X; the option followed by the information for the option as a pair. If X; the option is not of the correct form give an error message. Check X; to make sure the option exists. Also check that the form of option X; is legal according to the information returned. This includes X; whether the option is allowed as a symbol or in list form. And X; whether it is allowed to not have any arguments when in the list X; form. Also if a list, check if each element is a symbol, and not NIL. X; This is done if CHECK-ARGUMENTS was included in the option X; information. If the KEYWORDS option is also included with X; CHECK-ARGUMENTS, each of the symbols given must also be in the X; keyword package. If VARIABLES is included in the option information, X; SELF is also checked for each option element. The X; option CAN-HAVE-LIST-ELEMENTS causes list element arguments to be X; ignored. If this option is not there and a list element is X; found, an error message is issued. Type-info is used strictly for X; error messages. Will return NIL for the error conditions. Sample, X; X; OPTION = '(:REDEFINED-METHODS A B C)' or ':ALL-SETTABLE' X; X; TYPE-OF-OPTION is used to decide wheter we are dealing with an X; option or a suboption of :INHERIT-FROM. NOTE: Currently, this X; function will never return if an error occurs but we prepare for X; future continuable errors. X X (let* X ((option-info X (if (consp option) X X ; THEN Use the first element of the option as the option name. X X (return-option-info (car option) type-of-option) X X ; ELSE Use the option itself as the option name. X X (return-option-info option type-of-option))) X X (type-name (type-name type-info)) X (check-as-variables (member 'variable option-info :test #'eq)) X (can-have-list-elements X (member 'can-have-list-elements option-info :test #'eq)) X (keyword-arguments (member 'keywords option-info :test #'eq))) X X X (unless option-info X X ; THEN We have an illegal option. X X (co-deftype-error X "no such option (or suboption) as:~% '~s'." X type-name X option)) X X ; We have a real option. Make sure it is of the right form. X X (if (consp option) X X ; THEN Check to make sure it can be a pair. X X (if X (not (member 'list (cdr option-info) :test #'eq)) X X ; THEN Wrong form for option. X X (co-deftype-error X "option,~% '~S',~% must occur as a symbol." X type-name X option) X X ; ELSE Ok so far. Make sure the list form is a proper list. X ; Now check if the option has no arguments and if X ; if does make sure it can. X X (progn X (unless (proper-list option) X ; THEN Not a proper list. X (co-deftype-error X "the option,~% '~S',~% must be a proper list." X type-name X option)) X (if X (and (not (cdr option)) X (not (member 'no-arguments (cdr option-info) :test #'eq))) X X ; THEN Arguments must be specified to option. X X (co-deftype-error X "option,~% '~S',~% requires arguments." X type-name X option) X X ; ELSE Check each element of the list, if necessary, to X ; make sure it is a symbol, not NIL. Also check for X ; SELF if VARIABES is in the X ; option info. X ; Return the information. X X (progn X (when (member 'check-arguments (cdr option-info) :test #'eq) X X ; THEN Check the arguments. X X (dolist (option-arg (cdr option)) X (if (consp option-arg) X (unless can-have-list-elements X X ; THEN List arguments are not allowed. X X (co-deftype-error X "illegal argument '~S' found in option,~% '~S'." X type-name X option-arg X option)) X X ; ELSE Check if a correct symbol. X X (if X (or X (not (co-legal-type-or-method-name option-arg)) X (and check-as-variables X (not X (legal-instance-variable)))) X X ; THEN Illegal argument in option. X X (co-deftype-error X "illegal argument '~S' found in option,~% '~S'." X type-name X option-arg X option) X X ; ELSE Check if the option-arg must be a keyword. X X (when X (and keyword-arguments X (not (keywordp option-arg))) X X ; THEN We have a DEFINE-TYPE in which the X ; arguments must all be symbols in the X ; keyword package. X (co-deftype-error X "'~S' of the option,~%'~S'~%is illegal. Must be a symbol from the keyword package." X type-name X option-arg X option)))))) X (values (car option) option-info))))) X X ; ELSE We have the symbol form of the option. X X (if (member 'symbol (cdr option-info) :test #'eq) X X ; THEN Return the information. X X (values option option-info) X X ; ELSE Wrong form for option. X X (co-deftype-error X "option,~% '~S',~% must occur in list form." X type-name X option))))) X X X(defun co-legal-type-or-method-name (type-or-method-name) X X; Return T only if the name given is a non-nil symbol. X X (and (symbolp type-or-method-name) type-or-method-name)) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Detailed Option Parsing X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(defun return-option-info (option-name option-type) X X; Whenever a new option is added, this function must be updated. X; Should return NIL, if garbage option-names are given. The option X; information returned has the form: X; (FUNCTION-NAME . INFORMATION). X; FUNCTION-NAME is the name of the function to call that parses the X; given option. INFORMATION is a list of information to use in X; syntaxing the option. This list includes: X; SYMBOL - option can occur in symbol form. X; LIST - option can occur in list form. X; CHECK-ARGUMENTS - When an option is in list form, this specifies that X; each element of the option list is to be checked to X; be a symbol which is not NIL. X; KEYWORDS - An addition to the CHECK-ARGUMENTS option, this says X; that each element must be a symbol from the keyword X; package. Must occur with the CHECK-ARGUMENTS option. X; NO-ARGUMENTS - This specifies that a list form of the option can X; occur without any arguments (i.e., X; (:METHODS). X; VARIABLE - The items in this options list are instance variables. X; Check that they are not SELF or MYSELF.Make sure X; they are not symbols from the X; keyword package. X; CAN-HAVE-LIST-ELEMENTS - This option says that having list elements is X; legal. These elements are simply ignored. X; ONCE - This option can only occur once. X; VARIABLE-OPTION - Currently used in the :VAR option. Tells whether X; an option is a variable option (:VAR) without X; using the name of the option. This allows easy X; renaming of the :VAR option. X; VALUE-RETURNED-SUBOPTION - States that this suboption returns a X; value that is needed. A test is made X; to save the return value when a suboption X; has this characteristic. X; X; Note that this list is used for parsing suboptions as well as X; options. The handling of suboptions and options in the same way is X; done for flexibility and understandability even though some of the X; options may not currently apply to both options and suboptions. X; X X (case option-type X X (var-suboption (return-var-suboption-info option-name)) X X (inherit-from-suboption X (return-inherit-from-suboption-info option-name)) X X (regular-option (return-regular-option-info option-name)))) X X(defun return-var-suboption-info (option-name) X X; Return information as stated in comments of RETURN-OPTION-INFO X; about the suboptions of the :VAR option. X X (case option-name X X (:init '(parse-var-init-suboption list once value-returned-suboption)) X X (:type '(parse-var-type-suboption list once)) X X (:initable '(parse-var-initable-suboption symbol once)) X X (:settable '(parse-var-settable-suboption symbol once)) X X (:gettable '(parse-var-gettable-suboption symbol once)) X X (otherwise nil) X )) X X(defun parse-var-initable-suboption (args initable-variable type-info) X (declare (ignore args)) X X; ARGS will always be NIL. X X (setf (svref type-info $initable-variables-slot) X (add-to-set X (svref type-info $initable-variables-slot) X initable-variable))) X X(defun parse-var-gettable-suboption (args gettable-variable type-info) X (declare (ignore args)) X X; ARGS will always be NIL. X X (setf (svref type-info $gettable-variables-slot) X (add-to-set X (svref type-info $gettable-variables-slot) X gettable-variable))) X X(defun parse-var-settable-suboption (args settable-variable type-info) X (declare (ignore args)) X X; ARGS will always be NIL. X X (setf (svref type-info $initable-variables-slot) X (add-to-set X (svref type-info $initable-variables-slot) X settable-variable)) X X (setf (svref type-info $gettable-variables-slot) X (add-to-set X (svref type-info $gettable-variables-slot) X settable-variable)) X X (setf (svref type-info $settable-variables-slot) X (add-to-set X (svref type-info $settable-variables-slot) X settable-variable))) X X(defun add-to-set (set new-elements) X X; Add the elements in NEW-ELEMENTS to SET if they are not already X; there. NEW-ELEMENTS can be a list of id's or an id. It is assumed X; that the order of the elements within the set is NOT important. If X; NEW-ELEMENTS is NIL, simply return set. X X (cond ((null new-elements) set) X ((symbolp new-elements) X X ; THEN Add the element to the set, if necessary. X X (adjoin new-elements set :test #'eq)) X X (t X X ; ELSE Add each element of the list of elements. X X (let ((new-set set)) X (dolist (element new-elements) X (setf new-set (adjoin element new-set :test #'eq))) X new-set)))) X X X(defun parse-var-type-suboption (args variable type-info) X X; Example, ARGS = (FIXNUM). A declaration like (:TYPE FIXNUM) => X; (DECLARE (TYPE FIXNUM A)). X X (unless (and (consp args) (= (length args) 1)) ;rds 3/8 eq->= X X ; THEN We have something like (:TYPE . 2). X X (co-deftype-error X "'~S'~% is an illegal form of :TYPE suboption." X (type-name type-info) X (cons :type args))) X X; Add this declaration to the list of declarations. X; Note that more will be added to this slot when :VARIABLES suboptions are X; parsed, and at the end parsing the type. :VARIABLES is, however, X; currently unsupported. X X (setf (svref type-info $let-pseudo-info-slot) X (nconc (svref type-info $let-pseudo-info-slot) X (list `(declare (type ,(car args) ,variable)))))) X X X(defun parse-var-init-suboption (args variable type-info) X X; Return the variable initialization form. For example, if VARIABLE = X; REAL-PART and ARGS = (0.0), would return: X; (unless X; (assignedp real-part) X; (setf real-part 0.0)) X X (unless (and (consp args) (= (length args) 1)) ;rds 3/8 eq->= X X ; THEN We have something like (:INIT 1 2). X X (co-deftype-error X "illegal initialization form,~%'~S',~%given for instance variable '~S'." X (type-name type-info) X (cons :init args) X variable)) X X (let ((default-value (first args))) X `(unless X (co::assignedp ,variable) X X ; THEN X X (setf ,variable ,default-value)))) X X(defun return-inherit-from-suboption-info (option-name) X X; Return information as stated in comments of RETURN-OPTION-INFO X; about the suboptions of the :INHERIT-FROM option. X X (case option-name X X (:init-keywords X '(parse-init-keywords-suboption X symbol X list X once X check-arguments X keywords)) X X ;;:VARIABLES suboption not allowed in COOL. This is due to X ;; lack of code walker hooks. X X#| X (:variables X '(parse-variables-suboption X list X once X no-arguments X check-arguments X variable X can-have-list-elements)) X|# X X (:methods X '(parse-methods-suboption list once check-arguments no-arguments)) X X (otherwise nil))) X X(defun return-regular-option-info (option-name) X X; Return information as stated in comments of RETURN-OPTION-INFO X; about the options of DEFINE-TYPE. X X (case option-name X X X ;;:FAST-METHODS not supported in COOL. Implementation dependent. X X#| X (:fast-methods X '(parse-fast-methods-option list once check-arguments no-arguments)) X|# X X ;;In line methods are not supported in COOL. Implementation dependent. X X#| X (:inline-methods X '(parse-inline-methods-option list once check-arguments no-arguments)) X X (:notinline-methods X '(parse-notinline-methods-option X list X once X check-arguments X no-arguments)) X X|# X X (:init-keywords X '(parse-init-keywords-option X list X once X check-arguments X no-arguments X keywords)) X X (:no-init-keyword-check X '(parse-no-init-keyword-check-option symbol once)) X X (:inherit-from '(parse-inherit-from-option list)) X X (:var '(parse-var-option list variable-option)) X X (:redefined-methods X '(parse-redefined-methods-option X list X once X check-arguments X no-arguments)) X X (:all-settable '(parse-all-settable-option symbol once)) X X (:all-gettable '(parse-all-gettable-option symbol once)) X X (:all-initable '(parse-all-initable-option symbol once)) X X (otherwise nil))) X X(defun parse-init-keywords-suboption (type-info parent-type-info args) X X; If ARGS is NIL, we have the symbol form. If ARGS is a list, we have X; the list form. Examples: ARGS = NIL X; ARGS = (:EXCEPT j k l), (:EXCEPT) X; (:INIT-KEYWORDS :EXCEPT) is treated as all keywords. If this X; function returns, then everything went ok as far as errors. If ARGS X; is a list, we know it is proper, and each init keyword is a symbol and X; not NIL. This function may change the $INIT-KEYWORDS-SLOT of X; type-info. X X (let* X ((parent-init-keywords X (co::init-keywords parent-type-info)) X (keywords-to-add parent-init-keywords)) X X (when args X X ; THEN We have the except form. X ; Check and make sure the :EXCEPT is found. X X (if X (not (eq (car args) ':except)) X X ; THEN We have an error. X X (co-deftype-error X "~%'~S'~% was found following the :INIT-KEYWORDS suboption, expected to see 'EXCEPT'." X (type-name type-info) X (car args)) X X ; ELSE ok so far. X X (progn (setq args (cdr args)) X (when (consp args) X X ; THEN There is something following the :EXCEPT. X X (dolist (keyword args) X X ; See if the keyword is in the list of REAL X ; keywords for the parent. X X (if X (not X (member keyword X parent-init-keywords X :test X #'eq)) X X ; THEN Print a warning message is ignore. X X (warn X (format X NIL X "DEFINE-TYPE: Init keyword, '~A', is not a keyword of '~A' in :INIT-KEYWORDS suboption." X keyword X (type-name parent-type-info))) X X ; ELSE The keyword is legit. X X (setf keywords-to-add X (remove keyword X keywords-to-add X :test X #'eq X :count X 1)))))))) X X ; keywords-to-add should be correctly setup now. X ; Add the elements of this list that are not already there, to the X ; existing list of keywords for this type. X X (setf (svref type-info $INIT-KEYWORDS-SLOT) X (add-to-set X (svref type-info $INIT-KEYWORDS-SLOT) X keywords-to-add)))) X X(defun parse-methods-suboption (type-info parent-type-info args) X X; At this point, we know that ARGS is a proper list where each element X; is a symbol that is not NIL. Sample, args = (:EXCEPT M1 M2 M3), X; (:EXCEPT), (). If method names are duplicated, the duplicates are X; ignored. This function should change the $METHODS-TO-INHERIT-SLOT as X; in the following example: X; PARENT-TYPE-INFO for PARENT2 and the total methods for PARENT2 X; are M1, M2,...,M6 and if ARGS = (:EXCEPT M1 M2 M3), and if X; $METHODS-TO-INHERIT-SLOT looked like: X; ((<parent1 type info object> .(M1 M2 M3))), then X; $METHODS-TO-INHERIT-SLOT would look like: X; ((<parent1 type info object> . (M1 M2 M3)) X; (<parent2 type info object> . (M4 M5 M6))) X; after this routine completes. When this routine finishes, we are X; guaranteed that each method added to the $METHODS-TO-INHERIT-SLOT is an X; existing methods of the parent. X X (let X ((parent-methods X (co::method-alist parent-type-info)) X (methods-to-inherit nil) X (except-form? X (when (and args (eq (car args) ':except)) X X ; THEN Skip over the :EXCEPT argument. X X (setf args (cdr args)) X t))) X X ; ARGS will be NIL or a list at this point. If NIL, we have (:METHODS) X ; or (:METHODS :EXCEPT). X X (dolist (method args) X (unless (assoc method parent-methods :test #'eq) X X ; THEN The method doesn't exits, give a warning. X X (warn X (format nil X "DEFINE-TYPE: Method '~S' of the :METHODS suboption doesn't~% exist in parent '~S'." X method X (type-name parent-type-info))))) X X (if except-form? X X ; THEN We have the :EXCEPT form. List all methods that are not X ; specified and are not universal methods. If X ; (:METHODS :EXCEPT), all methods not universal methods are X ; added. X X (dolist (method-function-pair parent-methods) X X ; As long as the method is not an exception (:EXCEPT) X ; and not a universal method of the parent, inherit it. X X (unless X (or (member (car method-function-pair) args :test #'eq) X (member (car method-function-pair) X $DEFINE-TYPE-UNIVERSAL-METHODS X :test X #'eq)) X X ; THEN The method we are looking at is desired X ; for inheritance. X X (setf methods-to-inherit X (add-to-set X methods-to-inherit X (car method-function-pair))))) X X ; ELSE We have the normal form. If some of the args were not real X ; methods. If (:METHODS), nothing is done. X X (dolist (method args) X (when (assoc method parent-methods :test #'eq) X X ; THEN The method really exists. X X (setf methods-to-inherit X (add-to-set methods-to-inherit method)) X X ; Add to the list of explicitly stated methods to inherit. X ; This is used for error checking with methods to not X ; redefine later. X X (setf X (svref type-info $EXPLICITLY-LISTED-METHODS-SLOT) X (add-to-set X (svref type-info X $EXPLICITLY-LISTED-METHODS-SLOT) X method))))) X X ; Now add this list of methods to the type-info vector. X ; 'methods-to-inherit' may be NIL. X X (setf (svref type-info $METHODS-TO-INHERIT-SLOT) X (append (svref type-info $METHODS-TO-INHERIT-SLOT) X (list (cons parent-type-info methods-to-inherit)))))) X X X(defun parse-var-option (var-names args type-info) X X; ARGS = (IV1 (:TYPE INTEGER) (:INIT 0.0) :SETTABLE) Return something X; of the form: X; (VARIABLE-NAME . VAR-ASSIGNMENT) X; VARIABLE-NAME is the name of the instance variable. VAR-ASSIGNMENT X; is the code needed to initialize this instance variable. X X (unless (and (consp args) (symbolp (car args))) X X ; THEN We have an error. X X (co-deftype-error X "a symbol must follow a :VAR option." X (type-name type-info))) X X (let ((variable (car args)) X (var-assignment nil)) X X ; Make sure the instance variable name is legal. X X (instance-variable-ok? variable var-names (type-name type-info)) X X ; Now parse all the suboptions of the :VAR option. X ; VAR-ASSIGNMENT will be NIL if there is no :INIT suboption. X X (setf var-assignment X (parse-var-suboptions type-info (cdr args) variable)) X (values variable var-assignment))) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Detailed :VAR Suboption Parsing X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(defun parse-var-suboptions (type-info suboptions variable) X X; This routine returns the code for initialization of the instance X; variable VARIABLE. It is legal for suboptions to be NIL. For X; understandibility, expandability, and consistancy the parsing of X; suboptions uses the same techniques with the same keywords that option X; option parsing does. This is true even though some of the option X; information may not be shared between options and suboptions. See X; CO-PARSE-OPTIONS and its constituent routines. X; X; Example: SUBOPTIONS = ((:INIT 0.0) X; (:TYPE INTEGER) X; :SETTABLE) X X (let ((suboptions-so-far nil) X (suboption-name nil) X (suboption-info nil) X (init-info nil) X ) X X (dolist (suboption suboptions) X X ; SUBOPTION-INFO will be NIL if SUBOPTION-NAME is not a X ; legal suboption, or a list of information that tells what X ; characteristics this suboption has. Note that currently, X ; if an error occurs in SUBOPTION-OK? we will NOT return X ; to this function. The check for '(WHEN SUBOPTION-INFO...)' X ; is for future continuable errors. If 'ONCE' is on this X ; list, it means the suboption can only occur once. X X (multiple-value-setq (suboption-name suboption-info) X (option-ok? X suboption X type-info X 'var-suboption)) X (when suboption-info X X ; THEN The suboption is a real one. X ; Now make sure it doesn't occur more then once. X X (if X (and X (member suboption-name suboptions-so-far :test #'eq) X (member 'once (cdr suboption-info) :test #'eq)) X X ; THEN We have duplicate suboptions. Give an error. X X (co-deftype-error X "duplicate suboption,~% '~S',~% specified to :VAR option." X (type-name type-info) X suboption) X X ; ELSE Everything is ok. X X (progn X (setf suboptions-so-far X (cons suboption-name suboptions-so-far)) X (if X (member 'value-returned-suboption X (cdr suboption-info) X :test X #'eq) X X ; THEN We must save the return value. X X (setf init-info X (parse-var-suboption X type-info X variable X suboption X suboption-info)) X X ; ELSE We don't care about the return value. X X (parse-var-suboption X type-info X variable X suboption X suboption-info))))) X X ) ;dolist X X ;;Return the init-info X X init-info X X ) ;let X X) ;end parse-var-suboptions X X(defun parse-var-suboption (type-info variable suboption suboption-info) X X; This routine calls the right function to parse SUBOPTION. This X; function is the first element of SUBOPTION-INFO. Example: X; SUBOPTION = (:INIT 0.0) The SUBOPTION given is either a symbol or a X; list. When a list, the rest of the arguments will be passed to the X; function (may be NIL). If a symbol, NIL is passed as arguments. X; NOTE: Should make sure that the value returned by the suboption is X; the value of this routine, since some code may want to use X; the value returned (like the value of the :INIT suboption). X X (apply (car suboption-info) X (list (if (consp suboption) (cdr suboption) nil) X variable X type-info))) X X X(defun instance-variable-ok? (variable list-of-variables type-name) X X; Signal a standard error if the variable is SELF, X; one of the variables that are already in the list X; of variables, or a keyword. X; TYPE-NAME is used for error messages by CO-DEFTYPE-ERROR. X X (unless (legal-instance-variable variable) X X ; THEN error. X X (co-deftype-error X "'SELF' NIL, or symbol from the keyword package~%was found as an instance variable." X type-name)) X X (when (member variable list-of-variables :test #'eq) X X ; THEN We have a duplicate variable. X X (co-deftype-error X "instance variable '~S' occurs more~%than once." X type-name X variable))) X X(defun legal-instance-variable (variable) X X; Return T if VARIABLE satisfies restrictions on instance variables. X; Return NIL otherwise. Currently, the variable must be a non-NIL symbol X; that is not SELF. X; Must also be a symbol that is NOT in the X; keyword package. X X (and (symbolp variable) X variable X (not (eq variable 'co::self)) X (not (keywordp variable)))) X X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Parsing of :ALL-xxx X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(defun parse-all-initable-option (var-names args type-info) X X; Parses: :ALL-INITABLE. ARGS will be NIL. X X (parse-initable-option var-names args type-info)) X X(defun parse-all-gettable-option (var-names args type-info) X X; Parses: :ALL-GETTABLE. ARGS will be NIL. X X (parse-gettable-option var-names args type-info)) X X(defun parse-all-settable-option (var-names args type-info) X X; Parses: :ALL-SETTABLE. ARGS will be NIL. X X (parse-settable-option var-names args type-info)) X X(defun parse-gettable-option (var-names args type-info) X X; Example ARGS = (A B C D), NIL. X; Duplicate variables specified are ignored. X X (dolist (gettable-variable (or args var-names)) X X (if (member gettable-variable var-names :test #'eq) X X ; THEN This variable is a real instance variable. X X (setf (svref type-info $gettable-variables-slot) X (add-to-set X (svref type-info $GETTABLE-VARIABLES-SLOT) X gettable-variable)) X ; ELSE We have an illegal variable name. X X (co-deftype-error X "variable '~S' in the settable~% options list is not an instance variable.~%" X (type-name type-info) X gettable-variable)))) X X(defun parse-settable-option (var-names args type-info) X X; Example ARGS = (A B C D), NIL. Duplicate variables specified are X; ignored. Each settable instance variable X; is added to the list of gettable and initable instance variables as X; well. X X (dolist (settable-variable (or args var-names)) X X (if (not (member settable-variable var-names :test #'eq)) X X ; THEN We have an illegal variable name. X X (co-deftype-error X "variable '~S' in the settable~% options list is not an instance variable~%." X (type-name type-info) X settable-variable) X X ; ELSE This variable is a real instance variable. X X (progn X (setf (svref type-info $initable-variables-slot) X (add-to-set X (svref type-info $initable-variables-slot) X settable-variable)) X (setf (svref type-info $gettable-variables-slot) X (add-to-set X (svref type-info $gettable-variables-slot) X settable-variable)) X (setf (svref type-info $settable-variables-slot) X (add-to-set X (svref type-info $settable-variables-slot) X settable-variable)))))) X X(defun parse-initable-option (var-names args type-info) X X; Example ARGS = (A B C D), NIL. Duplicate X; variables specified are ignored. X X (dolist (initable-variable (or args var-names)) X X (if (member initable-variable var-names :test #'eq) X X ; THEN This variable is a real instance variable. X X (setf (svref type-info $initable-variables-slot) X (add-to-set X (svref type-info $initable-variables-slot) X X initable-variable)) X ; ELSE We have an (svref type-info $initable-variables-serror X "variable '~S' in the initable~% options list is not an instance variable.~%" X (type-name type-info) X initable-variable)))) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Parsing of :INIT-KEYWORDS Option and Suboption and :REDEFINED-METHODS X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(defun parse-init-keywords-option (var-names args type-info) X (declare (ignore var-names)) X X; Parses: (:INIT-KEYWORDS <symbol>). Doesn't use VAR-NAMES. By the X; time this routine is called, each element of args has been checked to X; be a symbol not equal to NIL. ARGS is also a proper list. For X; (:INIT-KEYWORDS), ARGS will be NIL. We add the existing X; init-keywords because we may have hit :INIT-KEYWORDS suboptions from X; :INHERIT-FROM options. X X (setf (svref type-info $INIT-KEYWORDS-SLOT) X (add-to-set (svref type-info $INIT-KEYWORDS-SLOT) args))) X X(defun parse-no-init-keyword-check-option (var-names args type-info) X (declare (ignore args var-names)) X X; Parses: :NO-INIT-KEYWORD-CHECK. VAR-NAMES is not used. X X (setf (svref type-info $NO-INIT-KEYWORD-CHECK-SLOT) t)) X X(defun parse-redefined-methods-option (var-names args type-info) X X (declare (ignore var-names)) X X; Parses: (:REDEFINED-METHODS M1 M2 M3), or (:REDEFINED-METHODS). ARGS X; = (M1 M2 M3). At this point, ARGS is guaranteed to be a proper list X; where each element is a symbol that is non-NIL. For X; (:REDEFINED-METHODS), args is NIL. NOTE: The order of arguments are X; stored away doesn't matter. X X (setf (svref type-info $methods-to-not-define-slot) X (remove-duplicates args :test #'eq))) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Parsing of :INHERIT-FROM Option and Suboption X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(defun parse-inherit-from-option (var-names args type-info) X (declare (ignore var-names)) X X; ARGS is the list of remaining stuff inside the :INHERIT-FROM option. X; We know that ARGS is a proper list and that it has at least one element. X; Sample: ARGS = (PARENT1 (:METHODS M1 M2 M3) X; (:VARIABLES X Y Z) X; (:INIT-KEYWORDS :EXCEPT Q)) X; VAR-NAMES is not used. Note that for error handling to be changed to X; continuable errors, these options will have to be changed, since side X; effects to type info can occur before a syntax error occurs. When X; finished, the $PARENT-TYPES-SLOT and the $PARENTS-INFO-SLOT may be X; changed. X X (if (and (consp args) (symbolp (car args))) X X ; THEN The form of the parent is ok. X ; Now check if it is partially defined. X X (let ((parent-type-info (type-partially-defined? (car args))) X (parents (svref type-info $PARENT-TYPES-SLOT)) X (new-parent (car args))) X X (if (not parent-type-info) X X ; THEN The parent isn't defined. Give an error. X X (co-deftype-error X "~%the parent '~s',~s of the :INHERIT-FROM option, is not defined." X (type-name type-info) X new-parent) X X ; ELSE The parent is partially defined. X ; First check that options specified are ok. X ; Add the parent to the type-info slot. We must append X ; since the order is important -- the first :INHERIT-FROM option X ; must be the first parent. X ; Check that we don't have something like: X ; (INHERIT-FROM B...) X ; (INHERIT-FROM B...) within the type definition. X (if X (member new-parent parents :test #'eq) X X ; THEN Two or more parents that are the same parent. X X (co-deftype-error X "~~Sarent '~s' of type '~s'~s can only be a parent once." X (type-name type-info) X new-parent X (type-name type-info)) X X ; ELSE Everything is ok. X ; Add the parents type-info to be used later. X ; This is stored in the same order as the parents in the X ; $PARENT-TYPES-SLOT for consistency. X X (progn X (set-parents-info X type-info X (append (get-parents-info type-info) X (list X (list new-parent parent-type-info '*place-holder*)))) X (setf (svref type-info $PARENT-TYPES-SLOT) X (append parents (list new-parent))) X (parse-inherit-from-suboptions X type-info X parent-type-info X (cdr args)))))) X X ; ELSE The parent form is illegal. X X (co-deftype-error X "~%a symbol must follow an :INHERIT-FROM~% option." X (type-name type-info)))) X X(defun parse-inherit-from-suboptions X (type-info parent-type-info suboptions) X X; It is legal for SUBOPTIONS to be NIL. For understandibility, X; expandability, and consistancy the parsing of subptions uses the same X; techniques with the same keywords for option information. This is X; true even though some of the option information may not be shared X; between options and suboptions. See CO-PARSE-OPTIONS and its X; constituent routines. NOTE: If the name of :METHODS option is ever X; changed (in RETURN-OPTION-INFO) the references to :METHODS must be X; changed here as well. X; X; Example: SUBOPTIONS = ((:VARIABLES A B) X; (:METHODS C D) X; (:INIT-KEYWORDS EXCEPT J)) X X (let ((suboptions-so-far nil) X (suboption-name nil) X (suboption-info nil)) X X (dolist (suboption suboptions) X X ; SUBOPTION-INFO will be NIL if SUBOPTION-NAME is not a X ; legal suboption, or a list of information that tells what X ; characteristics this suboption has. Note that currently, X ; if an error occurs in SUBOPTON-OK? we will NOT return X ; to this function. The check for (WHEN SUBOPTION-INFO...) X ; is for future continuable errors. If 'ONCE' is on this X ; list, it means the suboption can only occur once. X X (multiple-value-setq (suboption-name suboption-info) X (option-ok? X suboption X type-info X 'inherit-from-suboption)) X (when suboption-info X X ; THEN The suboption is a real one. X ; Now make sure it doesn't occur more then once. X X (if X (and (member suboption-name suboptions-so-far :test #'eq) X (member 'once (cdr suboption-info) :test #'eq)) X X ; THEN We have duplicate suboptions. Give an error. X X (co-deftype-error X "duplicate suboption,~s '~s',~s specified to :INHERIT-FROM option." X (type-name type-info) X suboption) X X ; ELSE Everything is ok. X X (progn X (setf suboptions-so-far X (cons suboption-name suboptions-so-far)) X (parse-inherit-from-suboption X type-info X parent-type-info X suboption X suboption-info))))) X X ; Now check the one funny case: If the :METHODS option was NOT present. X X (unless (member ':methods suboptions-so-far :test #'eq) X X ; THEN We had no :METHODS suboption, so inherit all methods X ; (but not universal methods). Do this by making X ; a suboption (:METHODS :EXCEPT), and having it parsed. X X (multiple-value-setq (suboption-name suboption-info) X (option-ok? X '(:methods :except) X type-info X 'inherit-from-suboption)) X X (parse-inherit-from-suboption X type-info X parent-type-info X '(:methods :except) X suboption-info)))) X X(defun parse-inherit-from-suboption X (type-info parent-type-info suboption suboption-info) X X; Example: SUBOPTION = (:INIT-KEYWORDS :EXCEPT J K L) The suboption X; given is either a symbol or a list. When a list, the rest of the X; arguments will be passed to the function (may be NIL). If a symbol, X; NIL is passed as arguments. X X (apply (car suboption-info) X (list type-info X parent-type-info X (if (consp suboption) (cdr suboption) nil)))) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Method Definition X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(defun co-parse-method-macro-call X (spec argument-list body) X X; Make sure that the type-name and method-name are ok. Also, that the X; call is a proper list. X; Note that use of instance variable names as formal X; parameter names to the method and use of SELF as a formal parameter X; name are not checked. X X (let X ( X (type-name NIL) X (method-name NIL) X ) X X ; Check to be sure the body is a proper list or NIL X X (unless (or (null body) (proper-list body)) X X ; THEN the method definition is not a proper list X X (define-method-error X "The call,~% '(DEFINE-METHOD ~S ~S ~S)',~% is missing arguments or is an improper list." X spec argument-list body)) X X ; Check the spec X X (unless (and (proper-list spec) (= (length spec) 2)) ;rds 3/8 eq->= X X ; THEN The form of the (type-name method-name) is incorrect. X X (define-method-error X "The type-name and method-name in the call,~% '(DEFINE-METHOD ~S ~S ~S)',~% must be a two element proper list." X spec argument-list body)) X X (setf method-name (second spec)) X (setf type-name (first spec)) X X (unless (co-legal-type-or-method-name type-name) X X ; THEN Invalid type. X X (define-method-error X "Type name '~S' in the call,~% '(DEFINE-METHOD ~S ~S ~S)',~% must be a non-NIL symbol." X type-name X spec X argument-list X body)) X X (unless (co-legal-type-or-method-name method-name) X X ; THEN Invalid method. X X (define-method-error X "Method name '~S' in the call,~% '(DEFINE-METHOD ~S ~S ~S)',~% must be a non-NIL symbol." X method-name X spec X argument-list X body)) X X ; Check that the argument-list is indeed a list. X X (unless (or (null argument-list) (proper-list argument-list)) X (define-method-error X "The argument list in the call,~% '(DEFINE-METHOD ~S ~S ~S)',~% is missing or must be a proper list." X spec X argument-list X body)) X X ) ;let X) ;co-parse-method-macro-call X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X; Call-Method Support X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X X(defun co-parse-call-to-method (call-method-call which-func class-name) X X; Parse a call to a CALL-METHOD or APPLY-METHOD. Signal any X; errors in syntax. X; 'which-func' is either "CALL-METHOD" or "APPLY-METHOD". X X (let ((method-name nil) X (rest-of-call call-method-call)) X X (setf rest-of-call (cdr rest-of-call)) X X ; This should now be the list of arguments X X (unless (proper-list rest-of-call) X X ; THEN The call to CALL-METHOD is not a proper list. X X (error X (format nil X "~A: The call,~% '~S',~% is missing arguments or is an improper list." X which-func X call-method-call))) X X ; If the form is APPLY-METHOD, check to be sure the argument list is X ; not NIl X X (when (equalp which-func "APPLY-METHOD") X (unless (cadr rest-of-call) X X (error X (format nil X "APPLY-METHOD: The call,~% '~S',~% has no argument list." X call-method-call X ) X ) X ) X ) X X (setf method-name (first rest-of-call)) X X (cond X ((co-legal-type-or-method-name method-name) X X ; THEN We have the local form of call-method (i.e., X ; (CALL-METHOD MOOSE 3) ) so just return. X X NIL X ) X X ; ELSE Check if a two element list, each element a symbol. X X ((consp method-name) X (unless X (and (= (length method-name) 2) X (proper-list method-name) X (co-legal-type-or-method-name (first method-name)) X (co-legal-type-or-method-name (second method-name)) X (co::legal-parent-p class-name (first method-name))) X X ; Incorrect parent form of call-method. X X (error X (format nil X "~A: Illegal parent reference '~S' in~% '~S'.~% Must have the form: '(type-symbol operation-symbol)'." X which-func X method-name X call-method-call) X )) X ) X X ; Anything else is an error. X X (t X (error X (format nil X "~A: Incorrect form '~S' in~% '~S'.~% Expecting non-NIL symbol or list or two non-NIL symbols." X which-func X method-name X call-method-call)))) X X ) ;let X X) ;co-parse-call-to-method X X(defun check-that-method-to-call-exists X (possible-method-name child-name parent-name parent-methods) X X; Return the name of the method we will be calling. X; The method name to use is determined as follows: First, always use the ':' X; version of the name. If the method with this name is not defined, X; check if the name without the ':' is defined. If it is, issue a X; warning message that we are calling this method. If it isn't X; defined, issue a warning message that the method is not defined and X; that we will call the ':' version when it is defined. For example, X; if we had the POSSIBLE-METHOD-NAME of A we would first check if a X; method named :A existed in the PARENT-METHODS. If it does, we X; return :A. If it doesn't, we see if a method with the name A X; exists. If it does, we return this name and give a warning. If it X; doesn't, we return :A and give a warning. X X (let* X ((method-to-call X (return-keyword-from-variable possible-method-name)) X (saved-method-to-call method-to-call)) X X (unless (assoc method-to-call parent-methods :test #'eq) X X ; THEN The ':' version of the method doesn't exist. X ; Now check if the non-colon version exists. X X (setf method-to-call possible-method-name) X X (if X (assoc method-to-call parent-methods :test #'eq) X X ; THEN We are calling the non-colon version of the method. X ; Give a warning message. X X (warn X (format nil X "DEFINE-TYPE: In type, '~A', '~A' of :VARIABLES suboption, will reference the parent method '~A'." X child-name X possible-method-name X possible-method-name)) X X ; ELSE Give a warning that we will assume calling the ':' version. X X (progn (setf method-to-call saved-method-to-call) X (warn X (format nil X "DEFINE-TYPE: In type, '~A', '~A' of :VARIABLES suboption, has no corresponding method defined in parent '~A'. Will assume you want to call method '~A'." X child-name X possible-method-name X parent-name X method-to-call))))) X method-to-call)) X X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; X END_OF_FILE if test 56836 -ne `wc -c <'co-parse.l'`; then echo shar: \"'co-parse.l'\" unpacked with wrong size! fi # end of 'co-parse.l' fi echo shar: End of archive 13 \(of 13\). cp /dev/null ark13isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 13 archives. rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 -- Rich $alz "Anger is an energy" Cronus Project, BBN Labs rsalz@bbn.com Moderator, comp.sources.unix sources@uunet.uu.net 
